home *** CD-ROM | disk | FTP | other *** search
/ Delphi Informant Complete 1995 - 2000 / Delphi Informant Complete 1995 to 2000.iso / Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar / 1998 / Mar / di9803rs / SNDXALGS.PAS < prev    next >
Pascal/Delphi Source File  |  1997-08-20  |  4KB  |  161 lines
  1. unit SndxAlgs;
  2.  
  3. interface
  4.  
  5. uses
  6.     SysUtils;
  7.  
  8.     function Soundex(in_str : String) : String;
  9.     function NumericSoundex(in_str : String) : Smallint;
  10.     function ExtendedSoundex(in_str : String) : String;
  11.  
  12. implementation
  13.  
  14. // Calculate a normal Soundex encoding.
  15. function Soundex(in_str : String) : String;
  16. var
  17.     no_vowels, coded, out_str : String;
  18.     ch                        : Char;
  19.     i                         : Integer;
  20. begin
  21.     // Make upper case and remove
  22.     // leading and trailing spaces.
  23.     in_str := Trim(UpperCase(in_str));
  24.  
  25.     // Remove vowels, spaces, H, W, and Y,
  26.     // except for the first character.
  27.     no_vowels := in_str[1];
  28.     for i := 2 to Length(in_str) do
  29.     begin
  30.         ch := in_str[i];
  31.         case ch of
  32.             'A', 'E', 'I', 'O', 'U', ' ', 'H', 'W', 'Y':
  33.                 ;    // Do nothing.
  34.         else
  35.             no_vowels := no_vowels + ch;
  36.         end;
  37.     end;
  38.  
  39.     // Encode the characters.
  40.     for i := 1 to Length(no_vowels) do
  41.     begin
  42.         ch := no_vowels[i];
  43.         case ch of
  44.             'B', 'F', 'P', 'V':
  45.                 ch := '1';
  46.             'C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z':
  47.                 ch := '2';
  48.             'D', 'T':
  49.                 ch := '3';
  50.             'L':
  51.                 ch := '4';
  52.             'M', 'N':
  53.                 ch := '5';
  54.             'R':
  55.                 ch := '6';
  56.         else    // Vowels, H, W, and Y as the 1st letter.
  57.                 ch := '0';
  58.         end;    // End case ch.
  59.         coded := coded + ch;
  60.     end;    // End for i := 1 to Length(no_vowels) do
  61.  
  62.     // Use the first letter.
  63.     out_str := no_vowels[1];
  64.  
  65.     // Find three non-repeating codes.
  66.     for i := 2 to Length(no_vowels) do
  67.     begin
  68.         // Look for a non-repeating code.
  69.         if (coded[i] <> coded[i - 1]) then
  70.         begin
  71.             // This one works.
  72.             out_str := out_str + coded[i];
  73.             if (Length(out_str) >= 4) then Break;
  74.         end;
  75.     end;
  76.  
  77.     Soundex := out_str;
  78. end;
  79.  
  80. // Calculate a numeric Soundex encoding.
  81. function NumericSoundex(in_str : String) : Smallint;
  82. var
  83.     value : Integer;
  84. begin
  85.     // Calculate the normal Soundex encoding.
  86.     in_str := Soundex(in_str);
  87.  
  88.     // Convert this into a numeric value.
  89.     value := (Ord(in_str[1]) - Ord('A')) * 1000;
  90.     if (Length(in_str) > 1) then
  91.         value := value +
  92.             StrToInt(Copy(in_str, 2, Length(in_str) - 1));
  93.  
  94.     NumericSoundex := value;
  95. end;
  96.  
  97. // Calculate an extended Soundex encoding.
  98. function ExtendedSoundex(in_str : String) : String;
  99.  
  100.     // Replace instances of fr_str with to_str in str.
  101.     procedure ReplaceString(var str : String;
  102.         fr_str, to_str : String);
  103.     var
  104.         fr_len, i : Integer;
  105.     begin
  106.         fr_len := Length(fr_str);
  107.         i := Pos(fr_str, str);
  108.         while (i > 0) do
  109.         begin
  110.             str :=
  111.                 Copy(str, 1, i - 1) +
  112.                 to_str +
  113.                 Copy(str, i + fr_len, Length(str) - i - fr_len + 1);
  114.             i := Pos(fr_str, str);
  115.         end;
  116.     end;
  117. var
  118.     no_vowels   : String;
  119.     ch, last_ch : Char;
  120.     i           : Integer;
  121. begin
  122.     // Make upper case and remove
  123.     // leading and trailing spaces.
  124.     in_str := Trim(UpperCase(in_str));
  125.  
  126.     // Remove internal spaces.
  127.     ReplaceString(in_str, ' ', '');
  128.  
  129.     // Convert CHR to CR.
  130.     ReplaceString(in_str, 'CHR', 'CR');
  131.  
  132.     // Convert PH to F.
  133.     ReplaceString(in_str, 'PH', 'F');
  134.  
  135.     // Convert Z to S.
  136.     ReplaceString(in_str, 'Z', 'S');
  137.  
  138.     // Remove vowels and repeats.
  139.     last_ch := in_str[1];  // The last character used.
  140.     no_vowels := last_ch;
  141.     for i := 2 to Length(in_str) do
  142.     begin
  143.         ch := in_str[i];
  144.         case ch of
  145.             'A', 'E', 'I', 'O', 'U':
  146.                 ;    // Do nothing.
  147.         else
  148.             // Skip it if it's a duplicate.
  149.             if (ch <> last_ch) then
  150.             begin
  151.                 no_vowels := no_vowels + ch;
  152.                 last_ch := ch;
  153.             end;
  154.         end;
  155.     end;
  156.  
  157.     ExtendedSoundex := no_vowels;
  158. end;
  159.  
  160. end.
  161.